home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / g0a.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  21KB  |  683 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* g0a -  initializations (corresponds to needed parts of adasem 0a.c */
  11.  
  12. #define GEN
  13.  
  14. #include "hdr.h"
  15. #include "vars.h"
  16. #include "gvars.h"
  17. #include "gutilp.h"
  18. #include "dbxp.h"
  19. #include "setp.h"
  20. #include "arithp.h"
  21. #include "miscp.h"
  22. #include "smiscp.h"
  23. #include "g0ap.h"
  24.  
  25. static Node val_node1(int);
  26. static Node val_nodea1(int);
  27. static Node val_node2(double);
  28. static Node val_node3(Rational);
  29. static void init_node_save(Node);
  30. static void sym_inits(Symbol, Symbol, Tuple, Symbol);
  31. static void sym_initg(Symbol, int, int, int);
  32.  
  33. static int    init_node_count = 0;
  34. extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
  35. extern int list_unit_0; /* set by gmain.c to list unit 0 structure */
  36.  
  37. void init_sem()                                            /*; init_sem */
  38. {
  39.     Tuple    constr_new, tup, boolean_constraint, constr_character, lmap;
  40.     Symbol    s;
  41.     int    i;
  42.     char   *p, *p1;
  43.     Symbol sym;
  44.     char    name[20];
  45.     static char *char_names[] = {
  46.         "NUL 0",
  47.         "SOH 1",
  48.         "STX 2",
  49.         "ETX 3",
  50.         "EOT 4",
  51.         "ENQ 5",
  52.         "ACK 6",
  53.         "BEL 7",
  54.         "BS 8",
  55.         "HT 9",
  56.         "LF 10",
  57.         "VT 11",
  58.         "FF 12",
  59.         "CR 13",
  60.         "SO 14",
  61.         "SI 15",
  62.         "DLE 16",
  63.         "DC1 17",
  64.         "DC2 18",
  65.         "DC3 19",
  66.         "DC4 20",
  67.         "NAK 21",
  68.         "SYN 22",
  69.         "ETB 23",
  70.         "CAN 24",
  71.         "EM 25",
  72.         "SUB 26",
  73.         "ESC 27",
  74.         "FS 28",
  75.         "GS 29",
  76.         "RS 30",
  77.         "US 31",
  78.         "EXCLAM 33",
  79.         "QUOTATION 34",
  80.         "SHARP 35",
  81.         "DOLLAR 36",
  82.         "PERCENT 37",
  83.         "AMPERSAND 38",
  84.         "COLON 58",
  85.         "SEMICOLON 59",
  86.         "QUERY 63",
  87.         "AT_SIGN 64",
  88.         "L_BRACKET 91",
  89.         "BACK_SLASH 92",
  90.         "R_BRACKET 93",
  91.         "CIRCUMFLEX 94",
  92.         "UNDERLINE 95",
  93.         "GRAVE 96",
  94.         "LC_A 97",
  95.         "LC_B 98",
  96.         "LC_C 99",
  97.         "LC_D 100",
  98.         "LC_E 101",
  99.         "LC_F 102",
  100.         "LC_G 103",
  101.         "LC_H 104",
  102.         "LC_I 105",
  103.         "LC_J 106",
  104.         "LC_K 107",
  105.         "LC_L 108",
  106.         "LC_M 109",
  107.         "LC_N 110",
  108.         "LC_O 111",
  109.         "LC_P 112",
  110.         "LC_Q 113",
  111.         "LC_R 114",
  112.         "LC_S 115",
  113.         "LC_T 116",
  114.         "LC_U 117",
  115.         "LC_V 118",
  116.         "LC_W 119",
  117.         "LC_X 120",
  118.         "LC_Y 121",
  119.         "LC_Z 122",
  120.         "L_BRACE 123",
  121.         "BAR 124",
  122.         "R_BRACE 125",
  123.         "TILDE 126",
  124.         "DEL 127",
  125.         " "
  126.     };
  127.     current_instances = tup_new(0);
  128.     lib_stub = tup_new(0);
  129.  
  130.     seq_node = tup_new(400);
  131.     seq_node_n = 0;
  132.  
  133.     seq_symbol = tup_new(100);
  134.     seq_symbol_n = 0;
  135.  
  136.     unit_nodes = tup_new(0);
  137. #ifdef TBSL
  138.     unit_nodes_n = 0;
  139. #endif
  140.  
  141.     stub_info = tup_new(0);
  142.     unit_number_now = 0;
  143.  
  144.     init_nodes = tup_new(30);
  145.     init_symbols = tup_new(0);
  146.  
  147.     interfaced_procedures = tup_new(0);
  148.  
  149.     OPT_NODE = node_new(as_opt);
  150.     N_LIST(OPT_NODE) = tup_new(0);
  151.     init_node_save(OPT_NODE);
  152.  
  153. #ifdef IBM_PC
  154.     /* avoid copy of literal for PC */
  155. #define setname(sym, str) ORIG_NAME(sym) = strjoin(str, "")
  156. #else
  157. #define setname(sym, str) ORIG_NAME(sym) = str
  158. #endif
  159.  
  160.     OPT_NAME = sym_new(na_obj);
  161.     setname(OPT_NAME, "opt_name");
  162.  
  163. #ifdef IBM_PC
  164. #define sym_op_enter(sym, name) sym = sym_new(na_op); \
  165.  ORIG_NAME(sym) = strjoin(name, "");
  166. #else
  167. #define sym_op_enter(sym, name) sym = sym_new(na_op); ORIG_NAME(sym) = name;
  168. #endif
  169.  
  170.     symbol_integer = sym_new(na_type);
  171.     /* note that val_node1 sets N_TYPE field to symbol_integer, so must
  172.      * define symbol_integer before calling val_node1
  173.      */
  174.     constr_new = constraint_new(CONSTRAINT_RANGE);
  175.     numeric_constraint_low(constr_new) = (char *) val_node1(ADA_MIN_INTEGER);
  176.     numeric_constraint_high(constr_new) = (char *)val_node1(ADA_MAX_INTEGER);
  177.     sym_inits(symbol_integer, symbol_integer, constr_new, symbol_integer);
  178.     sym_initg(symbol_integer, TK_WORD, 1, 3);
  179.     setname(symbol_integer, "INTEGER");
  180.  
  181.     constr_new = constraint_new(CONSTRAINT_RANGE);
  182.     numeric_constraint_low(constr_new) = (char *) val_node1(-32768);
  183.     numeric_constraint_high(constr_new) = (char *) val_node1(32767);
  184.     symbol_short_integer_base = sym_new(na_type);
  185.     sym_inits(symbol_short_integer_base, symbol_integer,
  186.       constr_new, symbol_short_integer);
  187.     sym_initg(symbol_short_integer_base, TK_WORD, 1, 77);
  188.     setname(symbol_short_integer_base, "SHORT_INTEGER\'base");
  189.  
  190.     symbol_short_integer = sym_new(na_type);
  191.     sym_inits(symbol_short_integer, symbol_short_integer_base,
  192.       SIGNATURE(symbol_short_integer_base), symbol_short_integer);
  193.     sym_initg(symbol_short_integer, TK_WORD, 1, 77);
  194.     setname(symbol_short_integer, "SHORT_INTEGER");
  195.     ALIAS(symbol_short_integer_base) = symbol_short_integer;
  196.  
  197.     symbol_universal_integer = sym_new(na_type);
  198.     sym_inits(symbol_universal_integer , symbol_integer, 
  199.       SIGNATURE(symbol_integer), symbol_integer);
  200.     sym_initg(symbol_universal_integer, TK_WORD, 1, 3);
  201.     setname(symbol_universal_integer, "universal_integer");
  202.  
  203.     constr_new = constraint_new(CONSTRAINT_DIGITS);
  204.     numeric_constraint_low(constr_new) = (char *) val_node2(ADA_MIN_REAL);
  205.     numeric_constraint_high(constr_new) = (char *) val_node2(ADA_MAX_REAL);
  206.     numeric_constraint_digits(constr_new) = (char *) val_node1(ADA_REAL_DIGITS);
  207.     symbol_float = sym_new(na_type);
  208.     sym_inits(symbol_float, symbol_float, constr_new, symbol_float);
  209.     /* TBSL: there should be TK_REAL for floating point */
  210.     sym_initg(symbol_float, TK_LONG, 1, 73);
  211.     setname(symbol_float, "FLOAT");
  212.  
  213.     symbol_universal_real = sym_new(na_type);
  214.     sym_inits(symbol_universal_real, symbol_float, 
  215.       SIGNATURE(symbol_float), symbol_universal_real);
  216.     sym_initg(symbol_universal_real, TK_LONG, 1, 73);
  217.     setname(symbol_universal_real, "universal_real");
  218.  
  219.     constr_new = constraint_new(CONSTRAINT_DELTA);
  220.     numeric_constraint_low(constr_new) = (char *) val_node3(rat_fri(int_fri(-1),
  221.       int_fri(0)));
  222.     numeric_constraint_high(constr_new) = (char *) val_node3(rat_fri(int_fri(1),
  223.       int_fri(0)));
  224.     numeric_constraint_delta(constr_new) =
  225.       (char *) val_node3(rat_fri(int_fri(0), int_fri(1)));
  226.     numeric_constraint_small(constr_new) = (char *) OPT_NODE;
  227.     symbol_dfixed = sym_new(na_type);
  228.     sym_inits(symbol_dfixed , symbol_dfixed, constr_new, symbol_dfixed);
  229.     sym_initg(symbol_dfixed, TK_LONG, 1, 67);
  230.     setname(symbol_dfixed, "$FIXED");
  231.  
  232.     constr_new = constraint_new(CONSTRAINT_RANGE);
  233.     numeric_constraint_low(constr_new) = (char *) val_node1(0);
  234.     numeric_constraint_high(constr_new) = (char *) val_node1(ADA_MAX_INTEGER);
  235.     symbol_natural = sym_new(na_subtype);
  236.     sym_inits(symbol_natural , symbol_integer, constr_new, symbol_integer);
  237.     sym_initg(symbol_natural, TK_WORD, 1, 57);
  238.     setname(symbol_natural, "NATURAL");
  239.  
  240.     constr_new = constraint_new(CONSTRAINT_RANGE);
  241.     numeric_constraint_low(constr_new) = (char *) val_node1(1);
  242.     numeric_constraint_high(constr_new) = (char *) val_node1(ADA_MAX_INTEGER);
  243.     symbol_positive = sym_new(na_subtype);
  244.     sym_inits(symbol_positive , symbol_integer,
  245.       constr_new, symbol_integer);
  246.     sym_initg(symbol_positive, TK_WORD, 1, 22);
  247.     setname(symbol_positive, "POSITIVE");
  248.  
  249.     constr_new = constraint_new(CONSTRAINT_DELTA);
  250.     numeric_constraint_low(constr_new) = (char *)
  251.       val_node3(rat_fri(int_frs("-86400000"), int_fri(1000)));
  252.     numeric_constraint_high(constr_new) =  (char *)
  253.       val_node3(rat_fri(int_frs("86400000"), int_fri(1000)));
  254.     numeric_constraint_delta(constr_new) = 
  255.       (char *) val_node3(rat_fri(int_fri(1), int_fri(1000)));
  256.     numeric_constraint_small(constr_new) = (char *)val_node3(rat_fri(int_fri(1),
  257.       int_fri(1000)));
  258.     symbol_duration = sym_new(na_type);
  259.     sym_inits(symbol_duration , symbol_duration, constr_new, symbol_dfixed);
  260.     sym_initg(symbol_duration, TK_LONG, 1, 61);
  261.     setname(symbol_duration, "DURATION");
  262.  
  263.     constr_character = constraint_new(CONSTRAINT_RANGE);
  264.     numeric_constraint_low(constr_character) = (char *) val_node1(0);
  265.     numeric_constraint_high(constr_character) = (char *) val_node1(127);
  266.     symbol_character = sym_new(na_enum);
  267.     sym_inits(symbol_character , symbol_character, constr_character,
  268.       symbol_character);
  269.     sym_initg(symbol_character, TK_WORD, 1, 43);
  270.     setname(symbol_character, "CHARACTER");
  271.  
  272.     constr_new = constraint_new(CONSTRAINT_RANGE);
  273.     numeric_constraint_low(constr_new) = (char *)val_node1(0);
  274.     numeric_constraint_high(constr_new) = (char *) val_node1(1);
  275.     /* save constraint - needed to initialize symbol_constrained below*/
  276.     boolean_constraint = constr_new;
  277.     symbol_boolean = sym_new(na_enum);
  278.     sym_inits(symbol_boolean,  symbol_boolean, constr_new, symbol_boolean);
  279.     sym_initg(symbol_boolean, TK_WORD, 1, 7);
  280.     setname(symbol_boolean, "BOOLEAN");
  281.  
  282.     tup = tup_new(2);
  283.     tup[1] =(char *) tup_new1((char *) symbol_positive);
  284.     tup[2] = (char *) symbol_character;
  285.     symbol_string = sym_new(na_array);
  286.     sym_inits(symbol_string , symbol_string, tup, symbol_string);
  287.     sym_initg(symbol_string, -1, 1, 26);
  288.     setname(symbol_string, "STRING");
  289.  
  290.     /* In SETL, symbol_string_type has a different signature from
  291.      * that defined by adasem. This symbol should never be
  292.      * used by the generator, so it seems safe to give it the
  293.      * same signature as is defined by adasem.
  294.      */
  295.     /* symbol_character_type references should not be produced by adasem.
  296.      * However, in those cases where they do occur they should be treated
  297.      * the same as for symbol_character, so we initialize 
  298.      * symbol_character_type to correspond to symbol_character.
  299.      *  ds 9-26-85
  300.      */
  301.     symbol_character_type = sym_new(na_enum);
  302.     sym_inits(symbol_character_type , symbol_character, constr_character,
  303.       symbol_character);
  304.     sym_initg(symbol_character_type, TK_WORD, 1, 43);
  305.     setname(symbol_character_type, "character_type");
  306.  
  307.     symbol_string_type = sym_new(na_array);
  308.     tup = tup_new(2);
  309.     tup[1] =(char *) tup_new1((char *) symbol_positive);
  310.     tup[2] = (char *) symbol_character_type;
  311.     sym_inits(symbol_string_type , symbol_string_type, tup, symbol_string_type);
  312.     sym_initg(symbol_string_type, -1, 1, 26);
  313.     setname(symbol_string_type, "string_type");
  314.  
  315.     symbol_daccess = sym_new(na_access);
  316.     sym_inits(symbol_daccess , symbol_daccess, tup_new(0), symbol_daccess);
  317.     sym_initg(symbol_daccess, TK_ADDR, 1, 1);
  318.     setname(symbol_daccess, "$ACCESS");
  319.  
  320.     symbol_null = sym_new(na_obj);
  321.     sym_inits(symbol_null , symbol_daccess, tup_new(0), symbol_null);
  322.     sym_initg(symbol_null, TK_ADDR, 255, 32767);
  323.     setname(symbol_null, "null");
  324.  
  325.     symbol_main_task_type = sym_new(na_task_type);
  326.     sym_inits(symbol_main_task_type , symbol_main_task_type, tup_new(0),
  327.       symbol_main_task_type);
  328.     sym_initg(symbol_main_task_type, TK_WORD, 1, 47);
  329.     setname(symbol_main_task_type, "main_task_type");
  330.  
  331.     /* The signature for symbol_constrained is its default_expr,
  332.      * and corresponds to the first value entered for symbol boolean (FALSE)
  333.      */
  334.     symbol_constrained = sym_new(na_discriminant);
  335.     sym_inits(symbol_constrained , symbol_boolean, 
  336.       (Tuple) numeric_constraint_low(boolean_constraint), symbol_constrained);
  337.     sym_initg(symbol_constrained, 0, 0, 0);
  338.     setname(symbol_constrained, "constrained");
  339.  
  340.     symbol_none = sym_new(na_type);
  341.     sym_inits(symbol_none , symbol_none, (Tuple)0, symbol_none);
  342.     sym_initg(symbol_none, 0, 0, 0);
  343.     setname(symbol_none, "none");
  344.  
  345.     symbol_standard0 = sym_new(na_package);
  346.     setname(symbol_standard0, "STANDARD#0");
  347.  
  348.     symbol_undef = sym_new(na_obj); /* for '?' case */
  349.     setname(symbol_undef, "?-undef");
  350.     symbol_standard = sym_new(na_package);
  351.     setname(symbol_standard, "standard");
  352.     symbol_unmentionable = sym_new(na_package);
  353.     setname(symbol_unmentionable, "unmentionable");
  354.     symbol_ascii = sym_new(na_package);
  355.     setname(symbol_ascii, "ASCII");
  356.     symbol_long_integer = sym_new(na_type);
  357.     setname(symbol_long_integer, "LONG_INTEGER");
  358.     symbol_long_float = sym_new(na_type);
  359.     setname(symbol_long_float, "LONG_FLOAT");
  360.     symbol_universal_fixed = sym_new(na_type);
  361.     setname(symbol_universal_fixed, "universal_fixed");
  362.     symbol_array_type = sym_new(na_array);
  363.     setname(symbol_array_type, "array_type");
  364.     symbol_discrete_type = sym_new(na_type);
  365.     setname(symbol_discrete_type, "discrete_type");
  366.     symbol_universal_integer_1 = sym_new(na_obj);
  367.     setname(symbol_universal_integer_1, "I:1");
  368.     symbol_any = sym_new(na_type);
  369.     setname(symbol_any, "any");
  370.     symbol_any_id = sym_new(na_obj);
  371.     root_type(symbol_any_id) = symbol_any;
  372.     setname(symbol_any_id, "any_id");
  373.     symbol_left = sym_new(na_in);
  374.     setname(symbol_left, "LEFT");
  375.     symbol_right = sym_new(na_in);
  376.     setname(symbol_right, "RIGHT");
  377.  
  378.     symbol_boolean_type = sym_new(na_type);
  379.     setname(symbol_boolean_type, "boolean_type");
  380.  
  381.     sym_op_enter(symbol_not, "not");
  382.     sym_op_enter(symbol_and, "and");
  383.     sym_op_enter(symbol_or, "or");
  384.     sym_op_enter(symbol_xor, "xor");
  385.     sym_op_enter(symbol_andthen, "andthen");
  386.  
  387.     sym_op_enter(symbol_orelse, "orelse");
  388.     sym_op_enter(symbol_assign, ":=");
  389.     sym_op_enter(symbol_eq, "=");
  390.     sym_op_enter(symbol_ne, "/=");
  391.     sym_op_enter(symbol_in, "IN");
  392.     sym_op_enter(symbol_notin, "NOTIN");
  393.  
  394.     symbol_order_type = sym_new(na_type);
  395.     setname(symbol_order_type, "order_type");
  396.  
  397.     sym_op_enter(symbol_lt, "<");
  398.     sym_op_enter(symbol_le, "<=");
  399.     sym_op_enter(symbol_ge, ">=");
  400.     sym_op_enter(symbol_gt, ">");
  401.  
  402.     symbol_numeric = sym_new(na_void);
  403.     setname(symbol_numeric, "numeric");
  404.  
  405.     sym_op_enter(symbol_addu, "+u");
  406.     sym_op_enter(symbol_subu, "-u");
  407.     sym_op_enter(symbol_abs, "abs");
  408.     sym_op_enter(symbol_add, "+");
  409.     sym_op_enter(symbol_sub, "-");
  410.     sym_op_enter(symbol_mul, "*");
  411.     sym_op_enter(symbol_div, "/");
  412.     sym_op_enter(symbol_mod, "mod");
  413.     sym_op_enter(symbol_rem, "rem");
  414.     sym_op_enter(symbol_exp, "**");
  415.     sym_op_enter(symbol_cat, "&");
  416.     sym_op_enter(symbol_cat_cc, "&cc");
  417.     sym_op_enter(symbol_cat_ac, "&ac");
  418.     sym_op_enter(symbol_cat_ca, "&ca");
  419.     s = sym_new(na_op);
  420. #ifdef IBM_PC
  421.     ORIG_NAME(s) = strjoin("any_op", "");
  422. #else
  423.     ORIG_NAME(s) = "any_op";
  424. #endif
  425.  
  426.     sym_op_enter(symbol_modi, "modi");
  427.     sym_op_enter(symbol_remi, "remi");
  428.     sym_op_enter(symbol_addui, "+ui");
  429.     sym_op_enter(symbol_subui, "-ui");
  430.     sym_op_enter(symbol_absi, "absi");
  431.     sym_op_enter(symbol_addi, "+i");
  432.     sym_op_enter(symbol_subi, "-i");
  433.     sym_op_enter(symbol_muli, "*i");
  434.     sym_op_enter(symbol_divi, "/i");
  435.     sym_op_enter(symbol_addufl, "+ufl");
  436.     sym_op_enter(symbol_subufl, "-ufl");
  437.     sym_op_enter(symbol_absfl, "absfl");
  438.     sym_op_enter(symbol_addfl, "+fl");
  439.     sym_op_enter(symbol_subfl, "-fl");
  440.     sym_op_enter(symbol_mulfl, "*fl");
  441.     sym_op_enter(symbol_divfl, "/fl");
  442.     sym_op_enter(symbol_addufx, "+ufx");
  443.     sym_op_enter(symbol_subufx, "-ufx");
  444.     sym_op_enter(symbol_absfx, "absfx");
  445.     sym_op_enter(symbol_addfx, "+fx");
  446.     sym_op_enter(symbol_subfx, "-fx");
  447.     sym_op_enter(symbol_mulfx, "*fx");
  448.     sym_op_enter(symbol_divfx, "/fx");
  449.     sym_op_enter(symbol_mulfxi, "*fxi");
  450.     sym_op_enter(symbol_mulifx, "*ifx");
  451.     sym_op_enter(symbol_divfxi, "/fxi");
  452.     sym_op_enter(symbol_mulfli, "*fli");
  453.     sym_op_enter(symbol_mulifl, "*ifl");
  454.     sym_op_enter(symbol_divfli, "/fli");
  455.  
  456.     sym_op_enter(symbol_expi, "**i");
  457.     sym_op_enter(symbol_expfl, "**fl");
  458.  
  459.     symbol_exception = sym_new(na_exception);/* ?? check this */
  460.     symbol_constraint_error = sym_new (na_exception);
  461.     setname(symbol_constraint_error, "CONSTRAINT_ERROR");
  462.     symbol_numeric_error = sym_new(na_exception);
  463.     setname(symbol_numeric_error, "NUMERIC_ERROR");
  464.     symbol_program_error = sym_new(na_exception);
  465.     setname(symbol_program_error, "PROGRAM_ERROR");
  466.     symbol_storage_error = sym_new(na_exception);
  467.     setname(symbol_storage_error, "STORAGE_ERROR");
  468.     symbol_tasking_error = sym_new(na_exception);
  469.     setname(symbol_tasking_error, "TASKING_ERROR");
  470.     symbol_system_error = sym_new(na_exception);
  471.     setname(symbol_system_error, "SYSTEM_ERROR");
  472.  
  473.  
  474.     /*
  475.      * Printable characters are entered into SYMBTAB, as overloaded
  476.      * literals whose source name is the character between single quotes.
  477.      */
  478.     {
  479.         int    i;
  480.         char   *s;
  481.         Symbol sy;
  482.         lmap = tup_new(2 * 128);
  483.  
  484.         for (i = 0; i <= 127; i++ ) {
  485.             s = smalloc(4);
  486.             s[3] = '\0';
  487.             s[0] = '\'';
  488.             s[1] = i;
  489.             s[2] = '\'';
  490.             lmap[2 * i + 1] = s;
  491.             lmap[2 * i + 2] =(char *) i;
  492.             /* if (i>=32 && i<=126 )   -- all ascii chars entered in SYMBTAB */
  493.             sy = sym_new(na_literal);
  494.             ORIG_NAME(sy) = s;
  495.         }
  496.         literal_map(symbol_character) =(Set) lmap;
  497.     }
  498.     for (i = 0; p = char_names[i]; i++) {
  499.         if (p[0] == ' ')
  500.             break;
  501.         p1 = strchr(p, ' ');
  502.         if (p1 == p)
  503.             break;
  504.         sym = sym_new(na_constant);
  505.         TYPE_OF(sym) = symbol_character;
  506.         SIGNATURE(sym) =(Tuple) val_nodea1(atoi(p1));
  507.         name[0] = '\0';
  508.         strncat(name, p, p1 - p);            /* extract string with name */
  509.         setname(sym, strjoin(name, ""));    /* p1 points to original name */
  510.     }
  511.  
  512.     s = sym_new(na_literal); 
  513.     setname(s, "FALSE");
  514.     TYPE_OF(s) = symbol_boolean;
  515.     s = sym_new(na_literal); 
  516.     setname(s, "TRUE");
  517.     TYPE_OF(s) = symbol_boolean;
  518.  
  519.     {
  520.         char   *litname;
  521.         lmap = tup_new(4);
  522.         litname = smalloc(6);
  523.         lmap[1] = strcpy(litname, "FALSE");
  524.         lmap[2] = (char *) 0;
  525.         litname = smalloc(5);
  526.         lmap[3] = strcpy(litname, "TRUE");
  527.         lmap[4] =(char *) 1;
  528.         literal_map(symbol_boolean) =(Set) lmap;
  529.     }
  530.  
  531.     /*   The only predefined aggregate is the one for string literals.*/
  532.     sym_new(na_aggregate);
  533.  
  534.     /* Next four symbols introduced for maps incp_types, priv_types */
  535.     symbol_private = sym_new(na_type);
  536.     setname(symbol_private, "private");
  537.     symbol_limited_private = sym_new(na_type);
  538.     setname(symbol_limited_private, "limited_private");
  539.     symbol_limited = sym_new(na_type);
  540.     setname(symbol_limited, "limited");
  541.     symbol_incomplete = sym_new(na_type);
  542.     setname(symbol_incomplete, "incomplete");
  543.  
  544.     /* the following symbols are used as markers by check_type in chapter 4 */
  545.     symbol_universal_type = sym_new(na_void);
  546.     setname(symbol_universal_type, "universal_type");
  547.     symbol_integer_type = sym_new(na_void);
  548.     setname(symbol_integer_type, "integer_type");
  549.     symbol_real_type = sym_new(na_void);
  550.     setname(symbol_real_type, "real_type");
  551.     symbol_composite_type = sym_new(na_void);
  552.     setname(symbol_composite_type, "composite_type");
  553.     symbol_equal_type = sym_new(na_void);
  554.     setname(symbol_equal_type, "equal_type");
  555.  
  556.     /* new symbol definitions that are common with the code generator should */
  557.     /* be placed before this comment.                         */
  558.  
  559.     /* 'task_block' is marker symbol used in expand.c - it need never be
  560.      * written out
  561.      */
  562.     symbol_task_block = sym_new(na_void);
  563.     /* Initialize bounds of predefined types. */
  564.     /* Note that val_node is only called from this procedure, so that
  565.      * calling sequence can be changed if necessary; moreover the code
  566.      * should be put in this module, not in utilities
  567.      */
  568.  
  569.     /* set size of init_nodes.
  570.      * NOTE, must NOT make any new entries to init_nodes after
  571.      * doing assignment of tup_size below    ds 24 sep 84
  572.      */
  573.     init_nodes[0] = (char *)init_node_count;
  574. #ifdef DEBUG
  575.     if (list_unit_0)
  576.         zpunit(0);
  577. #endif
  578. }
  579.  
  580. /* In C, need several versions of val_node, since we cannot test argument
  581.  * type as we can in SETL
  582.  */
  583.  
  584. static Node val_node1(int init_val)                                /*;val_node1*/
  585. {
  586.     /* Called from init_sem to initialize the bounds of predefined types.*/
  587.  
  588.     Node node;
  589.  
  590.     node = node_new(as_ivalue);
  591.     init_node_save(node);
  592.     /* INTEGER case */
  593.     N_TYPE(node) = symbol_integer;
  594.  
  595.     N_VAL(node) =(char *) int_const(init_val);
  596.     return node;
  597. }
  598.  
  599. static Node val_nodea1(int init_val)                            /*;val_nodea1*/
  600. {
  601.     /* Called from init_sem to initialize the bounds of predefined types.*/
  602.     /* like val_node1, but does not save generated node */
  603.  
  604.     Node node;
  605.  
  606.     node = node_new(as_ivalue);
  607.     /* INTEGER case */
  608.     N_TYPE(node) = symbol_integer;
  609.  
  610.     N_VAL(node) =(char *) int_const(init_val);
  611.     return node;
  612. }
  613.  
  614. static Node val_node2(double init_val)                        /*;val_node2*/
  615. {
  616.     /* Called from init_sem to initialize the bounds of predefined types.*/
  617.  
  618.     Node node;
  619.  
  620.     /* 'REAL' case */
  621.     node = node_new(as_ivalue);
  622.     init_node_save(node);
  623.  
  624.     N_TYPE(node) = symbol_float;
  625.  
  626.     N_VAL(node) = (char *)real_const(init_val);
  627.     return node;
  628. }
  629.  
  630. static Node val_node3(Rational init_val)                        /*;val_node3*/
  631. {
  632.     /* Called from init_sem to initialize the bounds of predefined types.*/
  633.  
  634.     Node node;
  635.  
  636.     node = node_new(as_ivalue);
  637.     init_node_save(node);
  638.     /* INTEGER TUPLE case */
  639.     N_TYPE(node) = symbol_universal_real;
  640.  
  641.     N_VAL(node) =(char *) rat_const(init_val);
  642.     return node;
  643. }
  644.  
  645. static void init_node_save(Node node)                        /*;init_node_save*/
  646. {
  647.     init_node_count += 1;
  648.     init_nodes[init_node_count] = (char *)node;
  649. }
  650.  
  651. static void sym_inits(Symbol sym, Symbol typ, Tuple sig, Symbol ali)
  652.                                                                   /*;sym_inits*/
  653. {
  654.     /* initialize standard part of symbol. These are the fields used
  655.      * by both adasem and adagen.
  656.      */
  657.  
  658.     TYPE_OF(sym) = typ;
  659.     SIGNATURE(sym) = sig;
  660.     ALIAS(sym) = ali;
  661. }
  662.  
  663. static void sym_initg(Symbol sym, int tkind, int r1, int r2)    /*;sym_initg*/
  664. {
  665.     /* initialize the fields of a symbol used only by the code generator */
  666.     if (tkind<=0) { /* if want to indicate type_size not defined */
  667.         TYPE_SIZE(sym) = -1;
  668.     }
  669.     else {
  670.         TYPE_KIND(sym) = tkind; /* type kind */
  671.         TYPE_SIZE(sym) = su_size(tkind); /* storage units needed*/
  672.     }
  673.     S_SEGMENT(sym) = r1;
  674.     S_OFFSET(sym) = r2;
  675.     /* Note that the correct values of offsets for most of the standard
  676.      * symbols are set by procedure main_data_segment() in glib.c
  677.      */
  678.     /* The following default value of MISC (happily) also corresponds to
  679.      * setting CONTAINS_TASK(sym) to FALSE.
  680.      */
  681.     MISC(sym) = (char *) 0;
  682. }
  683.